home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / PowerLisp 2.01 / PowerLisp 2.01 ƒ / Library / structures.lisp < prev    next >
Lisp/Scheme  |  1996-05-22  |  5KB  |  210 lines
  1. ;;;
  2. ;;;        PowerLisp 2.0
  3. ;;;        Copyright © 1996 Roger Corman.  All rights reserved.
  4. ;;;        PowerLisp Structure facility.
  5. ;;;
  6.  
  7. (provide :structures)
  8. (in-package :common-lisp)
  9.  
  10. (defmacro defstruct (name-and-options &rest doc-and-slots)
  11.     (let (    name 
  12.             options 
  13.             doc-string 
  14.             slot-descriptors 
  15.             struct-template
  16.             constructor-name
  17.             (boa-constructor-info nil)
  18.             (conc-name nil)
  19.             copier-name
  20.             predicate-name
  21.             accessor-name
  22.             (print-function nil)
  23.             setter-name
  24.             (slot-number 0)
  25.             (expressions nil)) 
  26.             
  27.         (if (symbolp name-and-options)
  28.             (setq name name-and-options)
  29.             (progn
  30.                 (if (or (not (consp name-and-options)) (not (symbolp (car name-and-options))))
  31.                     (error "Invalid syntax for defstruct name: ~A" name-and-options))
  32.                 (setq name (car name-and-options))
  33.                 (setq options (cdr name-and-options))))
  34.  
  35.         (setq conc-name (concatenate 'string (symbol-name name) "-"))
  36.  
  37.         (dolist (opt options)
  38.             (cond
  39.                 ((keywordp opt))
  40.                 ((and (listp opt) (keywordp (car opt)))
  41.                  (case (car opt)
  42.                     (:conc-name 
  43.                         (if (cdr opt)
  44.                             (setq conc-name 
  45.                                     (if (cadr opt) 
  46.                                         (symbol-name (cadr opt))
  47.                                         ""))))
  48.                     (:constructor 
  49.                         (if (cdr opt) 
  50.                             (if (cddr opt)
  51.                                 (setq boa-constructor-info (list (cadr opt) (caddr opt)))
  52.                                 (setq constructor-name (cadr opt)))))
  53.                     (:copier (if (cdr opt) (setq copier-name (cadr opt))))
  54.                     (:predicate (if (cdr opt) (setq predicate-name (cadr opt))))
  55.                     (:include (error "defstruct option not implemented: ~A~%" (car opt)))
  56.                     (:print-function (if (cdr opt) (setq print-function (cadr opt))))
  57.                     (:type (error "defstruct option not implemented: ~A~%" (car opt)))
  58.                     (:named t)
  59.                     (:initial-offset t)
  60.                     (otherwise (error "Unknown defstruct option: ~A~%" (car opt)))))
  61.                 (t (error "Invalid defstruct option: ~A~%" opt))))    
  62.  
  63.         (if (stringp (car doc-and-slots))
  64.             (progn
  65.                 (setq doc-string (car doc-and-slots))
  66.                 (setq slot-descriptors (cdr doc-and-slots)))
  67.             (setq slot-descriptors doc-and-slots))
  68.         
  69.         ;; add the doc string with structure attribute    
  70.         (if doc-string
  71.             (push 
  72.                 `(setf (documentation ',name 'structure) ,doc-string) 
  73.                 expressions))
  74.         
  75.         ;; process slot options
  76.         (push name struct-template)
  77.         
  78.         (dolist (opt slot-descriptors)
  79.             (cond
  80.                 ((symbolp opt)  
  81.                     (push (intern (symbol-name opt) :keyword) struct-template)
  82.                     (push nil struct-template))
  83.                 ((consp opt)
  84.                     (let ((sym (car opt)))
  85.                         (if (not (symbolp sym))
  86.                             (error "Invalid slot descriptor: ~A~%" sym))                    
  87.                         (push (intern (symbol-name sym) :keyword) struct-template)
  88.                         (push (cadr opt) struct-template)))
  89.                 (t (error "Invalid slot option: ~A~%" opt))))
  90.  
  91.         ;; install template        
  92.         (push
  93.             `(setf (get ',name :struct-template) 
  94.                 (apply #'define-struct-template ',(reverse struct-template)))
  95.             expressions)
  96.  
  97.         ;; install print function        
  98.         (if print-function
  99.             (push
  100.                 `(setf (get ',name :struct-print) 
  101.                     ',print-function)
  102.                 expressions))
  103.             
  104.         ;; install constructor function            
  105.         (setq constructor-name
  106.             (if constructor-name 
  107.                 (intern (symbol-name constructor-name))
  108.                 (intern (concatenate 'string "MAKE-" (symbol-name name)))))
  109.             
  110.         (push
  111.             `(setf (symbol-function ',constructor-name)
  112.                 #'(lambda (&rest args) 
  113.                     (_make-struct (get ',name :struct-template) args)))
  114.             expressions)
  115.  
  116.         (push
  117.             `(setf (get ',name ':struct-constructor) ',constructor-name)
  118.                 expressions) 
  119.         
  120.         ;; install BOA constructor
  121.         (if boa-constructor-info
  122.             (let ((order-list (mapcar 
  123.                                 #'(lambda (sym) 
  124.                                     (intern (symbol-name sym) (find-package :keyword))) 
  125.                                     (cadr boa-constructor-info))))
  126.                 (push
  127.                     `(setf (symbol-function ',(car boa-constructor-info))
  128.                         #'(lambda (&rest args) 
  129.                             (_make-struct-boa (get ',name :struct-template) 
  130.                                 ',order-list args)))
  131.                     expressions)))
  132.             
  133.         ;; install copier function            
  134.         (setq copier-name
  135.             (if copier-name 
  136.                 (intern (symbol-name copier-name))
  137.                 (intern (concatenate 'string "COPY-" (symbol-name name)))))
  138.             
  139.         (push
  140.             `(setf (symbol-function ',copier-name)
  141.                 #'(lambda (arg) (clone-struct arg)))
  142.             expressions)
  143.         
  144.         ;; install predicate function            
  145.         (setq predicate-name
  146.             (if predicate-name 
  147.                 (intern (symbol-name predicate-name))
  148.                 (intern (concatenate 'string (symbol-name name) "-P"))))
  149.             
  150.         (push
  151.             `(setf (symbol-function ',predicate-name)
  152.                 #'(lambda (arg) (_check-struct-type arg ',name)))
  153.             expressions)
  154.         
  155.         ;; install accessor functions
  156.         
  157.         (dolist (slot slot-descriptors)
  158.         
  159.             ;; install accessor function for this slot            
  160.             (setq accessor-name 
  161.                 (intern 
  162.                     (concatenate 'string conc-name 
  163.                         (symbol-name (if (symbolp slot) slot (car slot))))))
  164.             
  165.             (push
  166.                 `(setf (symbol-function ',accessor-name)
  167.                     #'(lambda (arg) (get-struct-field arg ,slot-number)))
  168.                 expressions)
  169.  
  170.             (setq setter-name (intern (concatenate 'string "%SET-" (symbol-name accessor-name))))        
  171.             
  172.             (push
  173.                 `(setf (symbol-function ',setter-name)
  174.                     #'(lambda (value arg) (set-struct-field value arg ,slot-number)))
  175.                 expressions)
  176.             (push `(defsetf ,accessor-name ,setter-name) expressions)    
  177.             (setq slot-number (1+ slot-number)))
  178.  
  179.         (push `',name expressions)    
  180.         (cons 'progn (reverse expressions))))
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.